(DE CLPARTITIONSL(CL LL)
               (IF (NOT LL)
                   THEN
                   (LIST NIL)
                   ELSE
                   (FOR NEW FP IN (CLPARTS CL (PLUSLIST (CAR LL)))
                        AS NEW RPL IS (CLPARTITIONSL (CLDIFF CL FP)
                                                     (CDR LL))
                        FOR NEW TP IN (CLPARTLP1 FP (CAR LL)
                                                 1)
                        FOR NEW RP IN RPL XLIST (CONS TP RP)))))))))))))
  (DE CLPARTLP1 (CL ROW N)
                  (IF (NOT ROW)
                      THEN
                      (LIST NIL)
                      ELSEIF
                      (ZEROP (CAR ROW))
                      THEN
                      (CLPARTLP1 CL (CDR ROW)
                                 (ADD1 N))
                      ELSE
                      (FOR NEW EP IN (CLPARTS CL (TIMES N (CAR ROW)))
                           AS NEW RPL IS (CLPARTLP1 (CLDIFF CL EP)
                                                    (CDR ROW)
                                                    (ADD1 N))
                           FOR NEW EEP IN (CL=PARTS EP (CAR ROW)
                                                    N)
                           FOR NEW RP IN RPL XLIST (APPEND
                             (CLCREATE EEP)
                             RP))))))))))))
)))))))))))))))))
  (DE KLOOPEDRINGS (P VL)
                     (IF (ZEROP P)
                         THEN
                         (NOLOOPEDRINGS VL)
                         ELSE
                         (FOR NEW LOOPPART IN (LOOPPARTITIONS P VL)
                              FOR NEW STRUC IN (NOFV-RINGS
                                (LOOPVL LOOPPART))
                              NCONC FIRST NIL (ATTACHBIVS&LOOPS
                                (EDGELABELS LOOPPART)
                                (LOOPLABELS LOOPPART)
                                STRUC))))))))))))
  (DE ATTACHBIVS&LOOPS  (EL LL STRUC)
         (IF (NOT EL)
             THEN
             (FOR NEW L2 IN (LLABELNODES STRUC (LCDRLIST LL))
                  XLIST
                  (PUTLOOPS (COPYSTRUC (LSTRUC L2))
                            (LCARLIST LL)
                            (LABELED L2)))
             ELSE
             (FOR NEW L1 IN (LABELEDGES STRUC (CDRLIST EL))
                  FOR NEW L2 IN (LLABELNODES (LSTRUC L1)
                                             (LCDRLIST LL))
                  XLIST
                  (PUTLOOPS (PUTBIVS (COPYSTRUC (LSTRUC L2))
                                     (CARLIST EL)
                                     (LABELED L1))
                            (LCARLIST LL)
                            (LABELED L2)))))))))))))

  (DE PUTLOOPS (STRUC LPS LNODES)
                       (PROG2 (FOR NEW LOBJ IN LNODES AS NEW LLABS IN 
                                   LPS FOR NEW OBJ IN LOBJ AS NEW LAB 
                                   IN LLABS FOR NEW LPPR IN LAB FOR NEW 
                                   I := (1 (CDR LPPR))
                                   FOR NEW NODE IN OBJ DO
                                   (SETQ STRUC (PUTBIVN STRUC NODE
                                                        (CAR LPPR))))
                              STRUC))))))))))
)))))))))))))))))

  (DE PUTBIVN  (STRUC NODE NBIVS)
                (IF (ZEROP NBIVS)
                    THEN STRUC ELSE
                    (PROG (B)
                          (SETQ B (BIVCHAIN NBIVS))
                          (CONNECT (CAR (CTABLE B))
                                   (SETQ NODE (FINDCTE NODE
                                                       (CTABLE STRUC))))
                          (CONNECT (CAR (LAST (CTABLE B)))
                                   NODE)
                          (NCONC (CTABLE STRUC)
                                 (CTABLE B))
                          (REPLACE (LASTNODE# STRUC)
                                   (LASTNODE# B))
                          (RETURN STRUC))))))))))))
)))))))))))))))))
  (DE PUTBIVS (S L LST)
                      (PROG2 (FOR NEW X IN LST AS NEW N IN L FOR NEW E 
                                  IN X DO (PUTBIVE S E N))
                             S)))))))))))

)))))))))))))))))
  (DE PUTBIVE (S E N)
                (IF (ZEROP N)
                    THEN S ELSE
                    (PROG (B N1 N2)
                          (SETQ B (BIVCHAIN N))
                          (CONNECT (CAR (CTABLE B))
                                   (SETQ N1 (FINDCTE (CAR E)
                                                     (CTABLE S))))
                          (CONNECT (CAR (LAST (CTABLE B)))
                                   (SETQ N2 (FINDCTE (CDR E)
                                                     (CTABLE S))))
                          (DISCONNECT N1 N2)
                          (NCONC (CTABLE S)
                                 (CTABLE B))
                          (REPLACE (LASTNODE# S)
                                   (LASTNODE# B))
                          (RETURN S))))))))))))
)))))))))))))))))
(DE COMBINE  (O1 O2)
        (IF (NOT O1) THEN O2
         ELSEIF (NOT O2) THEN O1
         ELSE (COMBINATION OBJ1 = O1 OBJ2 = O2))))
  ))

(DE CLASSES (OBJECTS STRUC)
        (IF (COMBINATION? OBJECTS)
           THEN (NCONC
                  (CLASSES (OBJ1 OBJECTS))
                  (CLASSES (OBJ2 OBJECTS)))
         ELSEIF (NOT (UNCLASSED? OBJECTS)) THEN (LIST OBJECTS)
         ELSE (CLASSES2 (OBJECTS OBJECTS) STRUC))))
  ))

(DE CLASSES2 (OBJECTS STRUC)
        (PROG NIL
            (SETQ OBJECTS (GROUPCOUNT OBJECTS))
            (RETURN (FOR NEW O IN (CDR OBJECTS)
              AS NEW M := (2 999999)
                FOR NEW O2 IN (CLASSIFY3 O STRUC)
                  XLIST FIRST (CLASSIFY3 (CAR OBJECTS) STRUC)
                     (MAKEMULT M O2))))))
  ))


(DE CLASSIFY3 (OBJECTS STRUC)
        (PROG (N E OTH)
            (FOR NEW X IN OBJECTS
              DO  (IF (NUMBERP X) THEN (CONSTO N X)
                 ELSEIF (AND (NUMBERP (CAR X)) (NUMBERP (CDR X)))
                   THEN (CONSTO E X)
                 ELSE (CONSTO OTH X)))
            (RETURN (NCONC
              (MAPCAR @MAKENODES(CLASSIFYNODES N STRUC) )
              (NCONC (MAPCAR @MAKEEDGES(CLASSIFYEDGES E STRUC) )
                     (IF OTH THEN (LIST (OTHERTYPE OTHOBJECTS = OTH))
                             ELSE NIL))))))
  ))
(DE CLASSIFYNODES (NODES SSTRUC)
        (CDRLIST (GROUPBY (FUNCTION NODEMARK) NODES))))
  ))

(DE CLASSIFYEDGES (EDGES SSTRUC)
        (CDRLIST (GROUPBY (FUNCTION EDGEMARK) EDGES))))
  ))

(DE NODEMARK (NODE)
        (PROG2
          (SETQ NODE (FINDCTE NODE SSTRUC))
          (CONS (NODEVALENCE NODE) (MARKERS NODE)))))
  ))